COMMENT ⊗   VALID 00005 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	ENTRY
C00003 00003	! mssngr buffer procedures: getfp,getfpa,getin,getina 
C00004 00004	! unfixment,affixment,move,rforce,array_parameters
C00008 00005	! $execute,$elfeval,$$gtvexpr,$$gtexpr
C00013 ENDMK
C⊗;
ENTRY;
BEGIN "EXEC"
DEFINE $$PRGID=TRUE;	DEFINE $EXEC=TRUE;
REQUIRE "HEADER.SAI" SOURCE_FILE;

! mssngr buffer procedures: getfp,getfpa,getin,getina ;

SIMPLE REAL PROCEDURE GETFP;
	RETURN($FPBUF[$FPPTR←$FPPTR+1]);

SIMPLE PROCEDURE GETFPA(REAL ARRAY A; INTEGER NDATA);
	BEGIN
	ARRBLT(A[1],$FPBUF[$FPPTR+1],NDATA);
	$FPPTR←$FPPTR+NDATA;
	END;

SIMPLE INTEGER PROCEDURE GETIN;
	RETURN($INBUF[$INTPTR←$INTPTR+1]);

SIMPLE PROCEDURE GETINA(INTEGER ARRAY A; INTEGER NDATA);
	BEGIN
	ARRBLT(A[1],$INBUF[$INTPTR+1],NDATA);
	$INTPTR←$INTPTR+NDATA;
	END;
! unfixment,affixment,move,rforce,array_parameters;

RPTR(FRAME)PROCEDURE GTFRMPTR(STRING MESS);
	BEGIN
	INTEGER I,DIM;
	RPTR(SYMBOL)S;
	RPTR(FRAME)F;
	I←GETIN;
	DIM←ARRYDIM(I,S);
	IF S AND SYMBOL:TYPE[S]≠#FR THEN ERROR(MESS);
	IF DIM THEN
		BEGIN
		INTEGER ARRAY ARR[1:DIM];
		GETINA(ARR,DIM);
		F←GTFRAME(I,DIM,ARR,S);
		END
	ELSE F←SYMBOL:OBJECT[S];
	RETURN(F);
	END;

PROCEDURE UNFIXMENT;
	BEGIN
	RPTR(FRAME)F1,F2;
	F1←GTFRMPTR("Unfixment of nonexistent frame");
	F2←GTFRMPTR("Unfixment of nonexistent frame");
	UFX_NODE(F1,F2);
	$FRLST←NULL;
	END;

PROCEDURE AFFIXMENT;
	BEGIN
	RPTR(FRAME)F1,F2; INTEGER AFFTYP;
	F1←GTFRMPTR("AFFIXMENT FROM NONEXISTENT FRAME");
	F2←GTFRMPTR("AFFIXMENT FROM NONEXISTENT FRAME");
	AFFTYP←GETIN;
	IF AFFTYP LAND #NONRGD THEN AFFTYP←#NRGLK ELSE AFFTYP←#RGDLK;
	AFX_NODE(F1,F2,AFFTYP);
	$FRLST←NULL;
	END;

SIMPLE INTEGER PROCEDURE COUNTBITS(INTEGER BITS);
	BEGIN INTEGER I,J,K;
	I←0;
	J←BITS LAND '177777;
	FOR K←1 STEP 1 UNTIL 16 DO
		BEGIN
		I←I + (J LAND 1);
		J←J LSH -1;
		END;
	RETURN(I);
	END;

PROCEDURE MOVE;
BEGIN	INTEGER CODE,SIZE,BITS,PNTS;
	BITS←GETIN;
	PNTS←GETIN;
	SIZE←COUNTBITS(BITS)*PNTS;
	IF SIZE>0 THEN
	    BEGIN
	    REAL ARRAY A[1:SIZE];
	    RPTR(GRAPHREC) G;
	    G←NEW_RECORD(GRAPHREC);
	    GRAPHREC:CTLBITS[G]←BITS;
	    GRAPHREC:NPNTS[G]←PNTS;
	    GRAPHREC:SIZE[G]←SIZE;
	    GETFPA(A,SIZE);
	    MEMORY[LOCATION(GRAPHREC:DATA[G])]↔MEMORY[LOCATION(A)];
	    GRAPTR←G;
	    END;
END;

PROCEDURE RFORCE;
	BEGIN INTEGER ARRAY DAT[1:10,1:9],DATA[1:90];
	GETINA(DATA,90);
	ARRBLT(DAT[1,1],DATA[1],90);
	WSTPTR←NEW_RECORD(WRISTREC);
	MEMORY[LOCATION(WRISTREC:DATA[WSTPTR])]↔MEMORY[LOCATION(DAT)];
	END;

! constructs the insides of the ARRAYREC record;
PROCEDURE ARRAY_PARAMETERS;
BEGIN
RPTR(ARRAYREC)SYMOBJ;
RPTR(SYMBOL)SYM;
INTEGER #DIM,#EL,OFFSET;
OFFSET←GETIN;
#EL←GETIN;
#DIM←GETIN;
	BEGIN
	INTEGER I,DIM;
	INTEGER ARRAY UB,LB,MULT[1:5];
	FOR I←1 STEP 1 UNTIL #DIM DO
		BEGIN UB[I]←GETIN;LB[I]←GETIN;
			MULT[I]←GETIN; END;
	DIM←ARRYDIM(OFFSET,SYM);
	IF SYM=NULL_RECORD THEN RETURN
	    ELSE IF SYMBOL:ACCESS[SYM]≠#ARRAY THEN ERROR("ERROR in ARRAY_PARAMETERS")
	    ELSE BEGIN
		SYMOBJ←SYMBOL:OBJECT[SYM];
		IF #DIM≠DIM THEN ERROR("ERROR IN ARRAY_PARAMETERS: incompatible number of dimensions");
		IF ARRAYREC:#EL[SYMOBJ]=0 THEN NWAREC(SYM,#EL,LB,UB,MULT);
		END;
	END;
END;
! $execute,$elfeval,$$gtvexpr,$$gtexpr;

INTERNAL PROCEDURE BUFFERUSAGE(STRING S);
	BEGIN
	STRING S1;
	IF $NOELF OR $ELFUNAVAILABLE THEN RETURN;
	S1←NULL;
	IF $INTPTR≠$INTSIZ THEN
		S1←"$INTPTR="&CVS($INTPTR)&":$INTSIZ="&CVS($INTSIZ)&" in "&S&CRLF;
	IF $FPPTR≠$FPSIZ THEN
		S1←S1&"$FPPTR="&CVS($FPPTR)&":$FPSIZ="&CVS($FPSIZ)&" in "&S&CRLF;
	IF S1 THEN ERROR(S1);
	END;


PROCEDURE FILREC(RANY S; INTEGER TYPE);
	CASE TYPE OF
		BEGIN
		[#SC]	SCALAR:VALUE[S]←GETFP;
		[#VT]	BEGIN
			VECTOR:XC[S]←GETFP;
			VECTOR:YC[S]←GETFP;
			VECTOR:ZC[S]←GETFP;
			END;
		[#RT]	GETFPA(ROT:XF[S],6);
		[#TR]	GETFPA(TRANS:XF[S],6);
		[#FR]	GETFPA(FRAME:XF[S],6);
		ELSE ERROR("error in $EVLARR")
		END;

INTERNAL PROCEDURE $EVLARR(RPTR(SYMBOL)SYM);
BEGIN
RPTR(EXPR$)E; RPTR(ARRAYREC)SYMOBJ;
INTEGER #EL,i;
IF SYMBOL:ACCESS[SYM]≠#ARRAY THEN ERROR("$EVLARR error: non array symbol");
E←EXPR$3(XRTARR,SYMBOL:OFFSET[SYM],XPDONE);
EVAL(E);
SYMOBJ←SYMBOL:OBJECT[SYM];
#EL←GETIN;
IF ARRAYREC:#EL[SYMOBJ]≠#EL THEN ERROR("$EVLARR error in array size");
FOR I←1 STEP 1 UNTIL #EL DO
	BEGIN RANY S;
	S←SYMBOL:OBJECT[ARRAYREC:PTR[SYMOBJ][I]];
	FILREC(S,SYMBOL:TYPE[S]);
	END;
BUFFERUSAGE("$EVLARR");
END;

INTERNAL RANY PROCEDURE $EVAL11(RPTR(SYMBOL)SYM);
	BEGIN
	RPTR(EXPR$) PPTR; RANY S;
	RPTR(EXPR$)E;
	IF SYMBOL:TYPE[SYM]≠#FR THEN
		PPTR←EXPR$R(SYM)
	ELSE BEGIN
		RPTR(FRAME)D,S;
		RPTR(SYMBOL)DADSYM,SONSYM;
		SONSYM←SYM;
		S←SYMBOL:OBJECT[SONSYM];
		D←FRAME:DAD[S];
		DADSYM←FRAME:SYM[D];
		IF D=F_WRLD THEN
			PPTR←EXPR$R(SONSYM)
			ELSE
			BEGIN
			RPTR(EXPR$) ARRAY P[1:4];
			P[1]←EXPR$G(DADSYM);
			P[2]←EXPR$1(XTINVRT);
			P[3]←EXPR$G(SONSYM);
			P[4]←EXPR$2(XTTMUL,XRTVAL);
			PPTR←$AAPPEND(P);
			END;
		END;
	S←SYMBOL:OBJECT[SYM];
	E←$APPEND(PPTR,EXPR$1(XPDONE));
	EVAL(E);
	FILREC(S,SYMBOL:TYPE[SYM]);
	BUFFERUSAGE("$EVAL11");
	RETURN(S);
	END;

INTERNAL RANY PROCEDURE $EVALEXP(RPTR(EXPR$)EX);
	BEGIN ! ex is of the form returned by idref;
	RANY S; INTEGER TY;
	RPTR(EXPR$)E;
	S←MK_REC(TY←EXPR$:TYPE[EX]);
	E←$APPEND(EX,EXPR$3(XGVALS,XRTVAL,XPDONE));
	EVAL(E);
	FILREC(S,TY);
	BUFFERUSAGE("$EVALEXP");
	RETURN(S);
	END;

INTERNAL RECURSIVE RPTR(EXPR$) PROCEDURE $ELFEVAL(RPTR(EXPR$)CUEXPR);
	BEGIN
	RPTR(EXPR$)ELFX;
	ELFX←$APPEND(CUEXPR,EXPR$1(XPDONE));
	EVAL(ELFX);
	RETURN(ELFX);
	END;

INTERNAL PROCEDURE TENINTERPRET;
	CASE GETIN OF
		BEGIN
		[XMOVE] MOVE;
		[XRFORCE] RFORCE;
		[XAFFIX] AFFIXMENT;
		[XUNFIX] UNFIXMENT;
		[XRTPARS] ARRAY_PARAMETERS;
		ELSE ERROR("unexpected value in control buffer")
		END;

INTERNAL RECURSIVE PROCEDURE $EXECUTE(RPTR(EXPR$)CUEXPR);
	BEGIN
	IF !PPCODE THEN PPCODE(CUEXPR);
	IF !PWCODE THEN PWCODE(CUEXPR);
	$ELFEVAL(CUEXPR);	! evaluate the expression on the ELF;
	WHILE $INTPTR<$INTSIZ DO TENINTERPRET;
	BUFFERUSAGE("$EXECUTE");
	END;


END "EXEC";